home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / X11BASE.C < prev    next >
C/C++ Source or Header  |  1992-05-21  |  56KB  |  1,835 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/x11base.c,v 1.40 1992/05/21 22:13:20 cph Exp $
  4.  
  5. Copyright (c) 1989-92 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Common X11 support. */
  36.  
  37. #include "scheme.h"
  38. #include "prims.h"
  39. #include "ux.h"
  40. #include "uxselect.h"
  41. #include "x11.h"
  42.  
  43. #ifndef X_DEFAULT_FONT
  44. #define X_DEFAULT_FONT "fixed"
  45. #endif
  46.  
  47. int x_debug = 0;
  48. static int initialization_done = 0;
  49.  
  50. #define INITIALIZE_ONCE()                        \
  51. {                                    \
  52.   if (!initialization_done)                        \
  53.     initialize_once ();                            \
  54. }
  55.  
  56. static void EXFUN (initialize_once, (void));
  57.  
  58. PTR
  59. DEFUN (x_malloc, (size), unsigned int size)
  60. {
  61.   PTR result = (UX_malloc (size));
  62.   if (result == 0)
  63.     error_external_return ();
  64.   return (result);
  65. }
  66.  
  67. PTR
  68. DEFUN (x_realloc, (ptr, size), PTR ptr AND unsigned int size)
  69. {
  70.   PTR result = (UX_realloc (ptr, size));
  71.   if (result == 0)
  72.     error_external_return ();
  73.   return (result);
  74. }
  75.  
  76. /* Allocation Tables */
  77.  
  78. struct allocation_table
  79. {
  80.   PTR * items;
  81.   int length;
  82. };
  83.  
  84. static struct allocation_table x_display_table;
  85. static struct allocation_table x_window_table;
  86. static struct allocation_table x_image_table;
  87. static struct allocation_table x_visual_table;
  88. static struct allocation_table x_colormap_table;
  89.  
  90. static void
  91. DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
  92. {
  93.   (table -> length) = 0;
  94. }
  95.  
  96. static unsigned int
  97. DEFUN (allocate_table_index, (table, item),
  98.        struct allocation_table * table AND
  99.        PTR item)
  100. {
  101.   unsigned int length = (table -> length);
  102.   unsigned int new_length;
  103.   PTR * items = (table -> items);
  104.   PTR * new_items;
  105.   PTR * scan;
  106.   PTR * end;
  107.   if (length == 0)
  108.     {
  109.       new_length = 4;
  110.       new_items = (x_malloc ((sizeof (PTR)) * new_length));
  111.     }
  112.   else
  113.     {
  114.       scan = items;
  115.       end = (scan + length);
  116.       while (scan < end)
  117.     if ((*scan++) == 0)
  118.       {
  119.         (*--scan) = item;
  120.         return (scan - items);
  121.       }
  122.       new_length = (length * 2);
  123.       new_items = (x_realloc (items, ((sizeof (PTR)) * new_length)));
  124.     }
  125.   scan = (new_items + length);
  126.   end = (new_items + new_length);
  127.   (*scan++) = item;
  128.   while (scan < end)
  129.     (*scan++) = 0;
  130.   (table -> items) = new_items;
  131.   (table -> length) = new_length;
  132.   return (length);
  133. }
  134.  
  135. static PTR
  136. DEFUN (allocation_item_arg, (arg, table),
  137.        unsigned int arg AND
  138.        struct allocation_table * table)
  139. {
  140.   unsigned int index = (arg_index_integer (arg, (table -> length)));
  141.   PTR item = ((table -> items) [index]);
  142.   if (item == 0)
  143.     error_bad_range_arg (arg);
  144.   return (item);
  145. }
  146.  
  147. struct xdisplay *
  148. DEFUN (x_display_arg, (arg), unsigned int arg)
  149. {
  150.   INITIALIZE_ONCE ();
  151.   return (allocation_item_arg (arg, (&x_display_table)));
  152. }
  153.  
  154. struct xwindow *
  155. DEFUN (x_window_arg, (arg), unsigned int arg)
  156. {
  157.   INITIALIZE_ONCE ();
  158.   return (allocation_item_arg (arg, (&x_window_table)));
  159. }
  160.  
  161. static struct xwindow *
  162. DEFUN (x_window_to_xw, (window), Window window)
  163. {
  164.   struct xwindow ** scan = ((struct xwindow **) (x_window_table . items));
  165.   struct xwindow ** end = (scan + (x_window_table . length));
  166.   while (scan < end)
  167.     {
  168.       struct xwindow * xw = (*scan++);
  169.       if ((XW_WINDOW (xw)) == window)
  170.     return (xw);
  171.     }
  172.   return (0);
  173. }
  174.  
  175. struct ximage *
  176. DEFUN (x_image_arg, (arg), unsigned int arg)
  177. {
  178.   INITIALIZE_ONCE ();
  179.   return (allocation_item_arg (arg, (&x_image_table)));
  180. }
  181.  
  182. unsigned int
  183. DEFUN (allocate_x_image, (image), XImage * image)
  184. {
  185.   struct ximage * xi = (x_malloc (sizeof (struct ximage)));
  186.   unsigned int index = (allocate_table_index ((&x_image_table), xi));
  187.   (XI_ALLOCATION_INDEX (xi)) = index;
  188.   (XI_IMAGE (xi)) = image;
  189.   return (index);
  190. }
  191.  
  192. void
  193. DEFUN (deallocate_x_image, (xi), struct ximage * xi)
  194. {
  195.   ((x_image_table . items) [XI_ALLOCATION_INDEX (xi)]) = 0;
  196.   free (xi);
  197. }
  198.  
  199. struct xvisual *
  200. DEFUN (x_visual_arg, (arg), unsigned int arg)
  201. {
  202.   INITIALIZE_ONCE ();
  203.   return (allocation_item_arg (arg, (&x_visual_table)));
  204. }
  205.  
  206. unsigned int
  207. DEFUN (allocate_x_visual, (visual), Visual * visual)
  208. {
  209.   struct xvisual * xv = (x_malloc (sizeof (struct xvisual)));
  210.   unsigned int index = (allocate_table_index ((&x_visual_table), xv));
  211.   (XV_ALLOCATION_INDEX (xv)) = index;
  212.   (XV_VISUAL (xv)) = visual;
  213.   return (index);
  214. }
  215.  
  216. void
  217. DEFUN (deallocate_x_visual, (xv), struct xvisual * xv)
  218. {
  219.   ((x_visual_table . items) [XV_ALLOCATION_INDEX (xv)]) = 0;
  220.   free (xv);
  221. }
  222.  
  223. struct xcolormap *
  224. DEFUN (x_colormap_arg, (arg), unsigned int arg)
  225. {
  226.   INITIALIZE_ONCE ();
  227.   return (allocation_item_arg (arg, (&x_colormap_table)));
  228. }
  229.  
  230. unsigned int
  231. DEFUN (allocate_x_colormap, (colormap, xd),
  232.        Colormap colormap AND
  233.        struct xdisplay * xd)
  234. {
  235.   struct xcolormap * xcm = (x_malloc (sizeof (struct xcolormap)));
  236.   unsigned int index = (allocate_table_index ((&x_colormap_table), xcm));
  237.   (XCM_ALLOCATION_INDEX (xcm)) = index;
  238.   (XCM_COLORMAP (xcm)) = colormap;
  239.   (XCM_XD (xcm)) = xd;
  240.   return (index);
  241. }
  242.  
  243. void
  244. DEFUN (deallocate_x_colormap, (xcm), struct xcolormap * xcm)
  245. {
  246.   ((x_colormap_table . items) [XCM_ALLOCATION_INDEX (xcm)]) = 0;
  247.   free (xcm);
  248. }
  249.  
  250. /* Error Handlers */
  251.  
  252. static int
  253. DEFUN (x_io_error_handler, (display), Display * display)
  254. {
  255.   fprintf (stderr, "\nX IO Error\n");
  256.   error_external_return ();
  257. }
  258.  
  259. static int
  260. DEFUN (x_error_handler, (display, error_event),
  261.        Display * display AND
  262.        XErrorEvent * error_event)
  263. {
  264.   char buffer [2048];
  265.   XGetErrorText (display, (error_event -> error_code),
  266.          buffer, (sizeof (buffer)));
  267.   fprintf (stderr, "\nX Error: %s\n", buffer);
  268.   fprintf (stderr, "         Request code: %d\n",
  269.        (error_event -> request_code));
  270.   fprintf (stderr, "         Error serial: %x\n", (error_event -> serial));
  271.   fflush (stderr);
  272.   error_external_return ();
  273. }
  274.  
  275. /* Defaults and Attributes */
  276.  
  277. static int
  278. DEFUN (x_decode_color, (display, color_map, color_name, color_return),
  279.        Display * display AND
  280.        Colormap color_map AND
  281.        char * color_name AND
  282.        unsigned long * color_return)
  283. {
  284.   XColor cdef;
  285.   if ((XParseColor (display, color_map, color_name, (&cdef)))
  286.       && (XAllocColor (display, color_map, (&cdef))))
  287.     {
  288.       (*color_return) = (cdef . pixel);
  289.       return (1);
  290.     }
  291.   return (0);
  292. }
  293.  
  294. static unsigned long
  295. DEFUN (arg_color, (arg, display),
  296.        unsigned int arg AND
  297.        Display * display)
  298. {
  299.   unsigned long result;
  300.   if (! (x_decode_color
  301.      (display,
  302.       (DefaultColormap (display, (DefaultScreen (display)))),
  303.       (STRING_ARG (arg)),
  304.       (&result))))
  305.     error_bad_range_arg (arg);
  306.   return (result);
  307. }
  308.  
  309. static void
  310. DEFUN (x_set_mouse_colors,
  311.        (display, mouse_cursor, mouse_pixel, background_pixel),
  312.        Display * display AND
  313.        Cursor mouse_cursor AND
  314.        unsigned long mouse_pixel AND
  315.        unsigned long background_pixel)
  316. {
  317.   Colormap color_map = (DefaultColormap (display, (DefaultScreen (display))));
  318.   XColor mouse_color;
  319.   XColor background_color;
  320.   (mouse_color . pixel) = mouse_pixel;
  321.   XQueryColor (display, color_map, (&mouse_color));
  322.   (background_color . pixel) = background_pixel;
  323.   XQueryColor (display, color_map, (&background_color));
  324.   XRecolorCursor (display, mouse_cursor, (&mouse_color), (&background_color));
  325. }
  326.  
  327. char *
  328. DEFUN (x_get_default,
  329.        (display, resource_name, resource_class,
  330.     property_name, property_class, sdefault),
  331.        Display * display AND
  332.        CONST char * resource_name AND
  333.        CONST char * resource_class AND
  334.        CONST char * property_name AND
  335.        CONST char * property_class AND
  336.        char * sdefault)
  337. {
  338.   char * result = (XGetDefault (display, resource_name, property_name));
  339.   if (result != 0)
  340.     return (result);
  341.   result = (XGetDefault (display, resource_class, property_name));
  342.   if (result != 0)
  343.     return (result);
  344.   result = (XGetDefault (display, resource_name, property_class));
  345.   if (result != 0)
  346.     return (result);
  347.   result = (XGetDefault (display, resource_class, property_class));
  348.   if (result != 0)
  349.     return (result);
  350.   return (sdefault);
  351. }
  352.  
  353. static unsigned long
  354. DEFUN (x_default_color,
  355.        (display, resource_class, resource_name,
  356.     property_name, property_class, default_color),
  357.        Display * display AND
  358.        CONST char * resource_name AND
  359.        CONST char * resource_class AND
  360.        CONST char * property_name AND
  361.        CONST char * property_class AND
  362.        unsigned long default_color)
  363. {
  364.   char * color_name =
  365.     (x_get_default
  366.      (display, resource_name, resource_class,
  367.       property_name, property_class, 0));
  368.   unsigned long result;
  369.   return
  370.     (((color_name != 0)
  371.       && (x_decode_color
  372.       (display,
  373.        (DefaultColormap (display, (DefaultScreen (display)))),
  374.        color_name,
  375.        (&result))))
  376.      ? result
  377.      : default_color);
  378. }
  379.  
  380. void
  381. DEFUN (x_default_attributes, 
  382.        (display, resource_name, resource_class, attributes),
  383.        Display * display AND
  384.        CONST char * resource_name AND
  385.        CONST char * resource_class AND
  386.        struct drawing_attributes * attributes)
  387. {
  388.   int screen_number = (DefaultScreen (display));
  389.   (attributes -> font) =
  390.     (XLoadQueryFont
  391.      (display,
  392.       (x_get_default
  393.        (display, resource_name, resource_class,
  394.     "font", "Font", X_DEFAULT_FONT))));
  395.   if ((attributes -> font) == 0)
  396.     error_external_return ();
  397.   {
  398.     char * s =
  399.       (x_get_default
  400.        (display, resource_name, resource_class,
  401.     "borderWidth", "BorderWidth", 0));
  402.     (attributes -> border_width) = ((s == 0) ? 1 : (atoi (s)));
  403.   }
  404.   {
  405.     char * s =
  406.       (x_get_default
  407.        (display, resource_name, resource_class,
  408.     "internalBorder", "BorderWidth", 0));
  409.     (attributes -> internal_border_width) =
  410.       ((s == 0) ? (attributes -> border_width) : (atoi (s)));
  411.   }
  412.   {
  413.     unsigned long white_pixel = (WhitePixel (display, screen_number));
  414.     unsigned long black_pixel = (BlackPixel (display, screen_number));
  415.     unsigned long foreground_pixel;
  416.     (attributes -> background_pixel) =
  417.       (x_default_color
  418.        (display, resource_class, resource_name,
  419.     "background", "Background", white_pixel));
  420.     foreground_pixel =
  421.       (x_default_color
  422.        (display, resource_class, resource_name,
  423.     "foreground", "Foreground", black_pixel));
  424.     (attributes -> foreground_pixel) = foreground_pixel;
  425.     (attributes -> border_pixel) =
  426.       (x_default_color
  427.        (display, resource_class, resource_name,
  428.     "borderColor", "BorderColor", foreground_pixel));
  429.     (attributes -> cursor_pixel) =
  430.       (x_default_color
  431.        (display, resource_class, resource_name,
  432.     "cursorColor", "Foreground", foreground_pixel));
  433.     (attributes -> mouse_pixel) =
  434.       (x_default_color
  435.        (display, resource_class, resource_name,
  436.     "pointerColor", "Foreground", foreground_pixel));
  437.   }
  438. }
  439.  
  440. /* Open/Close Windows and Displays */
  441.  
  442. #define MAKE_GC(gc, fore, back)                        \
  443. {                                    \
  444.   XGCValues gcv;                            \
  445.   (gcv . font) = fid;                            \
  446.   (gcv . foreground) = (fore);                        \
  447.   (gcv . background) = (back);                        \
  448.   (gc) =                                \
  449.     (XCreateGC (display,                        \
  450.         window,                            \
  451.         (GCFont | GCForeground | GCBackground),            \
  452.         (& gcv)));                        \
  453. }
  454.  
  455. struct xwindow *
  456. DEFUN (x_make_window, (xd, window, x_size, y_size, attributes, methods, extra),
  457.        struct xdisplay * xd AND
  458.        Window window AND
  459.        int x_size AND
  460.        int y_size AND
  461.        struct drawing_attributes * attributes AND
  462.        struct xwindow_methods * methods AND
  463.        unsigned int extra)
  464. {
  465.   GC normal_gc;
  466.   GC reverse_gc;
  467.   GC cursor_gc;
  468.   struct xwindow * xw;
  469.   Display * display = (XD_DISPLAY (xd));
  470.   Font fid = ((attributes -> font) -> fid);
  471.   unsigned long foreground_pixel = (attributes -> foreground_pixel);
  472.   unsigned long background_pixel = (attributes -> background_pixel);
  473.   Cursor mouse_cursor = (XCreateFontCursor (display, XC_left_ptr));
  474.   MAKE_GC (normal_gc, foreground_pixel, background_pixel);
  475.   MAKE_GC (reverse_gc, background_pixel, foreground_pixel);
  476.   MAKE_GC (cursor_gc, background_pixel, (attributes -> cursor_pixel));
  477.   x_set_mouse_colors
  478.     (display, mouse_cursor, (attributes -> mouse_pixel), background_pixel);
  479.   XDefineCursor (display, window, mouse_cursor);
  480.   XSelectInput (display, window, 0);
  481.   xw =
  482.     (x_malloc (((sizeof (struct xwindow)) - (sizeof (xw -> extra))) + extra));
  483.   (XW_ALLOCATION_INDEX (xw)) = (allocate_table_index ((&x_window_table), xw));
  484.   (XW_XD (xw)) = xd;
  485.   (XW_WINDOW (xw)) = window;
  486.   (XW_X_SIZE (xw)) = x_size;
  487.   (XW_Y_SIZE (xw)) = y_size;
  488.   (XW_CLIP_X (xw)) = 0;
  489.   (XW_CLIP_Y (xw)) = 0;
  490.   (XW_CLIP_WIDTH (xw)) = x_size;
  491.   (XW_CLIP_HEIGHT (xw)) = y_size;
  492.   (xw -> attributes) = (*attributes);
  493.   (xw -> methods) = (*methods);
  494.   (XW_NORMAL_GC (xw)) = normal_gc;
  495.   (XW_REVERSE_GC (xw)) = reverse_gc;
  496.   (XW_CURSOR_GC (xw)) = cursor_gc;
  497.   (XW_MOUSE_CURSOR (xw)) = mouse_cursor;
  498.   (XW_EVENT_MASK (xw)) = 0;
  499.   return (xw);
  500. }
  501.  
  502. static void
  503. DEFUN (x_close_window, (xw), struct xwindow * xw)
  504. {
  505.   Display * display = (XW_DISPLAY (xw));
  506.   ((x_window_table . items) [XW_ALLOCATION_INDEX (xw)]) = 0;
  507.   {
  508.     x_deallocator_t deallocator = (XW_DEALLOCATOR (xw));
  509.     if (deallocator != 0)
  510.       (*deallocator) (xw);
  511.   }
  512.   {
  513.     XFontStruct * font = (XW_FONT (xw));
  514.     if (font != 0)
  515.       XFreeFont (display, font);
  516.   }
  517.   XDestroyWindow (display, (XW_WINDOW (xw)));
  518.   free (xw);
  519. }
  520.  
  521. static void
  522. DEFUN (x_close_display, (xd), struct xdisplay * xd)
  523. {
  524.   struct xwindow ** scan = ((struct xwindow **) (x_window_table . items));
  525.   struct xwindow ** end = (scan + (x_window_table . length));
  526.   while (scan < end)
  527.     {
  528.       struct xwindow * xw = (*scan++);
  529.       if ((xw != 0) && ((XW_XD (xw)) == xd))
  530.     x_close_window (xw);
  531.     }
  532.   ((x_display_table . items) [XD_ALLOCATION_INDEX (xd)]) = 0;
  533.   XCloseDisplay (XD_DISPLAY (xd));
  534. }
  535.  
  536. static void
  537. DEFUN_VOID (x_close_all_displays)
  538. {
  539.   struct xdisplay ** scan = ((struct xdisplay **) (x_display_table . items));
  540.   struct xdisplay ** end = (scan + (x_display_table . length));
  541.   while (scan < end)
  542.     {
  543.       struct xdisplay * xd = (*scan++);
  544.       if (xd != 0)
  545.     x_close_display (xd);
  546.     }
  547. }
  548.  
  549. /* Window Manager Properties */
  550.  
  551. static void
  552. DEFUN (xw_set_class_hint, (xw, name, class),
  553.        struct xwindow * xw AND
  554.        CONST char * name AND
  555.        CONST char * class)
  556. {
  557.   XClassHint * class_hint = (XAllocClassHint ());
  558.   if (class_hint == 0)
  559.     error_external_return ();
  560.   /* This structure is misdeclared, so cast the args. */
  561.   (class_hint -> res_name) = ((char *) name);
  562.   (class_hint -> res_class) = ((char *) class);
  563.   XSetClassHint ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), class_hint);
  564.   XFree ((caddr_t) class_hint);
  565. }
  566.  
  567. void
  568. DEFUN (xw_set_wm_input_hint, (xw, input_hint),
  569.        struct xwindow * xw AND
  570.        int input_hint)
  571. {
  572.   XWMHints * hints = (XAllocWMHints ());
  573.   if (hints == 0)
  574.     error_external_return ();
  575.   (hints -> flags) = InputHint;
  576.   (hints -> input) = (input_hint != 0);
  577.   XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints);
  578.   XFree ((caddr_t) hints);
  579. }
  580.  
  581. void
  582. DEFUN (xw_set_wm_name, (xw, name), struct xwindow * xw AND CONST char * name)
  583. {
  584.   XTextProperty property;
  585.   if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
  586.     error_external_return ();
  587.   XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property));
  588. }
  589.  
  590. void
  591. DEFUN (xw_set_wm_icon_name, (xw, name),
  592.        struct xwindow * xw AND
  593.        CONST char * name)
  594. {
  595.   XTextProperty property;
  596.   if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
  597.     error_external_return ();
  598.   XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property));
  599. }
  600.  
  601. void
  602. DEFUN (x_decode_window_map_arg,
  603.        (map_arg, resource_name, resource_class, map_p),
  604.        SCHEME_OBJECT map_arg AND
  605.        CONST char ** resource_name AND
  606.        CONST char ** resource_class AND
  607.        int * map_p)
  608. {
  609.   (*map_p) = 0;
  610.   if (map_arg == SHARP_F)
  611.     (*map_p) = 1;
  612.   else if ((PAIR_P (map_arg))
  613.        && (STRING_P (PAIR_CAR (map_arg)))
  614.        && (STRING_P (PAIR_CDR (map_arg))))
  615.     {
  616.       (*resource_name) =
  617.     ((CONST char *) (STRING_LOC ((PAIR_CAR (map_arg)), 0)));
  618.       (*resource_class) =
  619.     ((CONST char *) (STRING_LOC ((PAIR_CDR (map_arg)), 0)));
  620.       (*map_p) = 1;
  621.     }
  622. }
  623.  
  624. void
  625. DEFUN (xw_make_window_map, (xw, resource_name, resource_class, map_p),
  626.        struct xwindow * xw AND
  627.        CONST char * resource_name AND
  628.        CONST char * resource_class AND
  629.        int map_p)
  630. {
  631.   xw_set_class_hint (xw, resource_name, resource_class);
  632.   if (map_p)
  633.     {
  634.       XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  635.       XFlush (XW_DISPLAY (xw));
  636.     }
  637. }
  638.  
  639. /* Event Processing */
  640.  
  641. static void
  642. DEFUN (xw_process_event, (xw, event),
  643.        struct xwindow * xw AND
  644.        XEvent * event)
  645. {
  646.   if (x_debug)
  647.     {
  648.       char * type_name;
  649.       fprintf (stderr, "\nX event: ");
  650.       switch (event -> type)
  651.     {
  652.     case ButtonPress:    type_name = "ButtonPress"; break;
  653.     case ButtonRelease:    type_name = "ButtonRelease"; break;
  654.     case CirculateNotify:    type_name = "CirculateNotify"; break;
  655.     case CreateNotify:    type_name = "CreateNotify"; break;
  656.     case DestroyNotify:    type_name = "DestroyNotify"; break;
  657.     case EnterNotify:    type_name = "EnterNotify"; break;
  658.     case Expose:        type_name = "Expose"; break;
  659.     case FocusIn:        type_name = "FocusIn"; break;
  660.     case FocusOut:        type_name = "FocusOut"; break;
  661.     case GraphicsExpose:    type_name = "GraphicsExpose"; break;
  662.     case GravityNotify:    type_name = "GravityNotify"; break;
  663.     case KeyPress:        type_name = "KeyPress"; break;
  664.     case KeyRelease:    type_name = "KeyRelease"; break;
  665.     case LeaveNotify:    type_name = "LeaveNotify"; break;
  666.     case MapNotify:        type_name = "MapNotify"; break;
  667.     case MappingNotify:    type_name = "MappingNotify"; break;
  668.     case MotionNotify:    type_name = "MotionNotify"; break;
  669.     case NoExpose:        type_name = "NoExpose"; break;
  670.     case ReparentNotify:    type_name = "ReparentNotify"; break;
  671.     case UnmapNotify:    type_name = "UnmapNotify"; break;
  672.     case VisibilityNotify:    type_name = "VisibilityNotify"; break;
  673.     case ConfigureNotify:
  674.       {
  675.         fprintf (stderr, "ConfigureNotify; width = %d, height = %d",
  676.              ((event -> xconfigure) . width),
  677.              ((event -> xconfigure) . height));
  678.         goto debug_done;
  679.       }
  680.     case ClientMessage:
  681.       {
  682.         struct xdisplay * xd = (XW_XD (xw));
  683.         if ((((event -> xclient) . message_type) == (XD_WM_PROTOCOLS (xd)))
  684.         && (((event -> xclient) . format) == 32))
  685.           {
  686.         if (((Atom) (((event -> xclient) . data . l) [0]))
  687.             == (XD_WM_DELETE_WINDOW (xd)))
  688.           type_name = "WM_DELETE_WINDOW";
  689.         else if (((Atom) (((event -> xclient) . data . l) [0]))
  690.              == (XD_WM_TAKE_FOCUS (xd)))
  691.           type_name = "WM_TAKE_FOCUS";
  692.         else
  693.           type_name = "WM_PROTOCOLS";
  694.           }
  695.         else
  696.           {
  697.         fprintf (stderr,
  698.              "ClientMessage; message_type = 0x%x, format = %d",
  699.              ((event -> xclient) . message_type),
  700.              ((event -> xclient) . format));
  701.         goto debug_done;
  702.           }
  703.       }
  704.       break;
  705.     default:        type_name = 0; break;
  706.     }
  707.       if (type_name != 0)
  708.     fprintf (stderr, "%s", type_name);
  709.       else
  710.     fprintf (stderr, "%d", (event -> type));
  711.     debug_done:
  712.       fprintf (stderr, "\n");
  713.       fflush (stderr);
  714.     }
  715.   switch (event -> type)
  716.     {
  717.     case MappingNotify:
  718.       switch ((event -> xmapping) . request)
  719.     {
  720.     case MappingKeyboard:
  721.     case MappingModifier:
  722.       XRefreshKeyboardMapping (& (event -> xmapping));
  723.       break;
  724.     }
  725.       break;
  726.     }
  727.   (* (XW_EVENT_PROCESSOR (xw))) (xw, event);
  728. }
  729.  
  730. enum event_type
  731. {
  732.   event_type_button_down,
  733.   event_type_button_up,
  734.   event_type_configure,
  735.   event_type_enter,
  736.   event_type_focus_in,
  737.   event_type_focus_out,
  738.   event_type_key_press,
  739.   event_type_leave,
  740.   event_type_motion,
  741.   event_type_expose,
  742.   event_type_delete_window,
  743.   event_type_map,
  744.   event_type_unmap,
  745.   event_type_take_focus,
  746.   event_type_visibility,
  747.   event_type_supremum
  748. };
  749.  
  750. #define EVENT_MASK_ARG(arg)                        \
  751.   (arg_index_integer ((arg), (1 << ((unsigned int) event_type_supremum))))
  752.  
  753. #define EVENT_ENABLED(xw, type)                        \
  754.   (((XW_EVENT_MASK (xw)) & (1 << ((unsigned int) (type)))) != 0)
  755.  
  756. #define EVENT_0 2
  757. #define EVENT_1 3
  758. #define EVENT_2 4
  759. #define EVENT_3 5
  760.  
  761. #define EVENT_INTEGER(event, slot, number)                \
  762.   VECTOR_SET ((event), (slot), (long_to_integer (number)))
  763.  
  764. static SCHEME_OBJECT
  765. DEFUN (make_event_object, (xw, type, extra),
  766.        struct xwindow * xw AND
  767.        enum event_type type AND
  768.        unsigned int extra)
  769. {
  770.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, (2 + extra), 1));
  771.   VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM ((long) type)));
  772.   VECTOR_SET (result, 1, (XW_TO_OBJECT (xw)));
  773.   return (result);
  774. }
  775.  
  776. static SCHEME_OBJECT
  777. DEFUN (button_event, (xw, event, type),
  778.        struct xwindow * xw AND
  779.        XButtonEvent * event AND
  780.        enum event_type type)
  781. {
  782.   SCHEME_OBJECT result = (make_event_object (xw, type, 4));
  783.   EVENT_INTEGER (result, EVENT_0, (event -> x));
  784.   EVENT_INTEGER (result, EVENT_1, (event -> y));
  785.   {
  786.     SCHEME_OBJECT conversion;
  787.     int button_number;
  788.     switch (event -> button)
  789.       {
  790.       case Button1: button_number = 1; break;
  791.       case Button2: button_number = 2; break;
  792.       case Button3: button_number = 3; break;
  793.       case Button4: button_number = 4; break;
  794.       case Button5: button_number = 5; break;
  795.       default: button_number = 0; break;
  796.       }
  797.     if (button_number) {
  798.       --button_number;
  799.       if ((event -> state) & ShiftMask) {
  800.     button_number += 5;
  801.       }
  802.       if ((event -> state) & ControlMask) {
  803.     button_number += 10;
  804.       }
  805.       if ((event -> state) & Mod1Mask) {
  806.     button_number += 20;
  807.       }
  808.       conversion = (LONG_TO_UNSIGNED_FIXNUM (button_number));
  809.     } else {
  810.       conversion = (SHARP_F);
  811.     }
  812.     VECTOR_SET (result, EVENT_2, conversion);
  813.   }
  814.   EVENT_INTEGER (result, EVENT_3, (event -> time));
  815.   return (result);
  816. }
  817.  
  818. static SCHEME_OBJECT
  819. DEFUN (convert_bucky_bits, (state, allp), unsigned int state AND int allp)
  820. {
  821.   long bucky = 0;
  822.   if (state & Mod1Mask)    bucky |= 0x0001; /* meta */
  823.   if (state & ControlMask) bucky |= 0x0002; /* control */
  824.   if (state & Mod2Mask)    bucky |= 0x0004; /* super */
  825.   if (state & Mod3Mask)    bucky |= 0x0008; /* hyper */
  826.   if (state & Mod4Mask)    bucky |= 0x0010; /* top */
  827.   if (allp)
  828.     {
  829.       if (state & ShiftMask)   bucky |= 0x0020;
  830.       if (state & LockMask)    bucky |= 0x0040;
  831.       if (state & Mod2Mask)    bucky |= 0x0080;
  832.       if (state & Mod5Mask)    bucky |= 0x0100;
  833.       if (state & Button1Mask) bucky |= 0x0200;
  834.       if (state & Button2Mask) bucky |= 0x0400;
  835.       if (state & Button3Mask) bucky |= 0x0800;
  836.       if (state & Button4Mask) bucky |= 0x1000;
  837.       if (state & Button5Mask) bucky |= 0x2000;
  838.     }
  839.   return (LONG_TO_UNSIGNED_FIXNUM (bucky));
  840. }
  841.  
  842. static XComposeStatus compose_status;
  843.  
  844. static SCHEME_OBJECT
  845. DEFUN (key_event, (xw, event, type),
  846.        struct xwindow * xw AND
  847.        XKeyEvent * event AND
  848.        enum event_type type)
  849. {
  850.   char copy_buffer [80];
  851.   KeySym keysym;
  852.   int nbytes;
  853.  
  854.   /* Make ShiftLock modifier not affect keys with other modifiers. */
  855.   if ((event -> state) &
  856.       (ShiftMask || ControlMask
  857.        || Mod1Mask || Mod2Mask || Mod3Mask || Mod4Mask || Mod5Mask))
  858.     {
  859.       if (((event->state) & LockMask) != 0)
  860.     (event->state) -= LockMask;
  861.     }
  862.   nbytes =
  863.     (XLookupString (event,
  864.             copy_buffer,
  865.             (sizeof (copy_buffer)),
  866.             (&keysym),
  867.             (&compose_status)));
  868.   if (IsModifierKey (keysym))
  869.     return (SHARP_F);
  870.   else
  871.     {
  872.       SCHEME_OBJECT result = (make_event_object (xw, type, 4));
  873.       VECTOR_SET (result, EVENT_0,
  874.           (memory_to_string (nbytes,
  875.                      ((unsigned char *) copy_buffer))));
  876.       /* Create Scheme bucky bits (kept independent of the character).
  877.      X has already controlified, so Scheme may choose to ignore
  878.      the control bucky bit.  */
  879.       VECTOR_SET (result, EVENT_1, (convert_bucky_bits ((event -> state), 0)));
  880.       /* Move vendor-specific bit from bit 28 (zero-based) to bit 23
  881.      so that all keysym values will fit in Scheme fixnums.  */
  882.       VECTOR_SET
  883.     (result,
  884.      EVENT_2,
  885.      (LONG_TO_UNSIGNED_FIXNUM ((keysym & 0xffffff)
  886.                    | (0x800000 & (keysym >> 5)))));
  887.       EVENT_INTEGER (result, EVENT_3, (event -> time));
  888.       return (result);
  889.     }
  890. }
  891.  
  892. #define CONVERT_TRIVIAL_EVENT(scheme_name)                \
  893.   if (EVENT_ENABLED (xw, scheme_name))                    \
  894.     result = (make_event_object (xw, scheme_name, 0));            \
  895.   break
  896.  
  897. static SCHEME_OBJECT
  898. DEFUN (x_event_to_object, (event), XEvent * event)
  899. {
  900.   struct xwindow * xw = (x_window_to_xw ((event -> xany) . window));
  901.   SCHEME_OBJECT result = SHARP_F;
  902.   switch (event -> type)
  903.     {
  904.     case KeyPress:
  905.       if (EVENT_ENABLED (xw, event_type_key_press))
  906.     result = (key_event (xw, (& (event -> xkey)), event_type_key_press));
  907.       break;
  908.     case ButtonPress:
  909.       if (EVENT_ENABLED (xw, event_type_button_down))
  910.     result =
  911.       (button_event (xw, (& (event -> xbutton)), event_type_button_down));
  912.       break;
  913.     case ButtonRelease:
  914.       if (EVENT_ENABLED (xw, event_type_button_up))
  915.     result =
  916.       (button_event (xw, (& (event -> xbutton)), event_type_button_up));
  917.       break;
  918.     case MotionNotify:
  919.       if (EVENT_ENABLED (xw, event_type_motion))
  920.     {
  921.       result = (make_event_object (xw, event_type_motion, 3));
  922.       EVENT_INTEGER (result, EVENT_0, ((event -> xmotion) . x));
  923.       EVENT_INTEGER (result, EVENT_1, ((event -> xmotion) . y));
  924.       VECTOR_SET (result, EVENT_2,
  925.               (convert_bucky_bits (((event -> xmotion) . state), 1)));
  926.     }
  927.       break;
  928.     case ConfigureNotify:
  929.       if (EVENT_ENABLED (xw, event_type_configure))
  930.     {
  931.       result = (make_event_object (xw, event_type_configure, 2));
  932.       EVENT_INTEGER (result, EVENT_0, ((event -> xconfigure) . width));
  933.       EVENT_INTEGER (result, EVENT_1, ((event -> xconfigure) . height));
  934.     }
  935.       break;
  936.     case Expose:
  937.       if (EVENT_ENABLED (xw, event_type_expose))
  938.     {
  939.       result = (make_event_object (xw, event_type_expose, 4));
  940.       EVENT_INTEGER (result, EVENT_0, ((event -> xexpose) . x));
  941.       EVENT_INTEGER (result, EVENT_1, ((event -> xexpose) . y));
  942.       EVENT_INTEGER (result, EVENT_2, ((event -> xexpose) . width));
  943.       EVENT_INTEGER (result, EVENT_3, ((event -> xexpose) . height));
  944.     }
  945.       break;
  946.     case GraphicsExpose:
  947.       if (EVENT_ENABLED (xw, event_type_expose))
  948.     {
  949.       result = (make_event_object (xw, event_type_expose, 4));
  950.       EVENT_INTEGER (result, EVENT_0, ((event -> xgraphicsexpose) . x));
  951.       EVENT_INTEGER (result, EVENT_1, ((event -> xgraphicsexpose) . y));
  952.       EVENT_INTEGER (result, EVENT_2,
  953.              ((event -> xgraphicsexpose) . width));
  954.       EVENT_INTEGER (result, EVENT_3,
  955.              ((event -> xgraphicsexpose) . height));
  956.     }
  957.       break;
  958.     case ClientMessage:
  959.       {
  960.     struct xdisplay * xd = (XW_XD (xw));
  961.     if ((((event -> xclient) . message_type) == (XD_WM_PROTOCOLS (xd)))
  962.         && (((event -> xclient) . format) == 32))
  963.       {
  964.         if (((Atom) (((event -> xclient) . data . l) [0]))
  965.         == (XD_WM_DELETE_WINDOW (xd)))
  966.           {
  967.         if (EVENT_ENABLED (xw, event_type_delete_window))
  968.           result =
  969.             (make_event_object (xw, event_type_delete_window, 0));
  970.           }
  971.         else if (((Atom) (((event -> xclient) . data . l) [0]))
  972.              == (XD_WM_TAKE_FOCUS (xd)))
  973.           {
  974.         if (EVENT_ENABLED (xw, event_type_take_focus))
  975.           {
  976.             result =
  977.               (make_event_object (xw, event_type_take_focus, 1));
  978.             EVENT_INTEGER
  979.               (result, EVENT_0, (((event -> xclient) . data . l) [1]));
  980.           }
  981.           }
  982.       }
  983.       }
  984.       break;
  985.     case VisibilityNotify:
  986.       if (EVENT_ENABLED (xw, event_type_visibility))
  987.     {
  988.       unsigned int state;
  989.       switch ((event -> xvisibility) . state)
  990.         {
  991.         case VisibilityUnobscured:
  992.           state = 0;
  993.           break;
  994.         case VisibilityPartiallyObscured:
  995.           state = 1;
  996.           break;
  997.         case VisibilityFullyObscured:
  998.           state = 2;
  999.           break;
  1000.         default:
  1001.           state = 3;
  1002.           break;
  1003.         }
  1004.       result = (make_event_object (xw, event_type_visibility, 1));
  1005.       EVENT_INTEGER (result, EVENT_0, state);
  1006.     }
  1007.       break;
  1008.     case EnterNotify: CONVERT_TRIVIAL_EVENT (event_type_enter);
  1009.     case LeaveNotify: CONVERT_TRIVIAL_EVENT (event_type_leave);
  1010.     case FocusIn: CONVERT_TRIVIAL_EVENT (event_type_focus_in);
  1011.     case FocusOut: CONVERT_TRIVIAL_EVENT (event_type_focus_out);
  1012.     case MapNotify: CONVERT_TRIVIAL_EVENT (event_type_map);
  1013.     case UnmapNotify: CONVERT_TRIVIAL_EVENT (event_type_unmap);
  1014.     }
  1015.   return (result);
  1016. }
  1017.  
  1018. static void
  1019. DEFUN (update_input_mask, (xw), struct xwindow * xw)
  1020. {
  1021.   {
  1022.     long event_mask = 0;
  1023.     if (EVENT_ENABLED (xw, event_type_expose))
  1024.       event_mask |= ExposureMask;
  1025.     if ((EVENT_ENABLED (xw, event_type_configure))
  1026.     || (EVENT_ENABLED (xw, event_type_map))
  1027.     || (EVENT_ENABLED (xw, event_type_unmap)))
  1028.       event_mask |= StructureNotifyMask;
  1029.     if (EVENT_ENABLED (xw, event_type_button_down))
  1030.       event_mask |= ButtonPressMask;
  1031.     if (EVENT_ENABLED (xw, event_type_button_up))
  1032.       event_mask |= ButtonReleaseMask;
  1033.     if (EVENT_ENABLED (xw, event_type_key_press))
  1034.       event_mask |= KeyPressMask;
  1035.     if (EVENT_ENABLED (xw, event_type_enter))
  1036.       event_mask |= EnterWindowMask;
  1037.     if (EVENT_ENABLED (xw, event_type_leave))
  1038.       event_mask |= LeaveWindowMask;
  1039.     if ((EVENT_ENABLED (xw, event_type_focus_in))
  1040.     || (EVENT_ENABLED (xw, event_type_focus_out)))
  1041.       event_mask |= FocusChangeMask;
  1042.     if (EVENT_ENABLED (xw, event_type_motion))
  1043.       event_mask |= (PointerMotionMask | PointerMotionHintMask);
  1044.     if (EVENT_ENABLED (xw, event_type_visibility))
  1045.       event_mask |= VisibilityChangeMask;
  1046.     XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask);
  1047.   }
  1048.   {
  1049.     struct xdisplay * xd = (XW_XD (xw));
  1050.     Atom protocols [2];
  1051.     unsigned int n_protocols = 0;
  1052.     if (EVENT_ENABLED (xw, event_type_delete_window))
  1053.       (protocols[n_protocols++]) = (XD_WM_DELETE_WINDOW (xd));
  1054.     if (EVENT_ENABLED (xw, event_type_take_focus))
  1055.       (protocols[n_protocols++]) = (XD_WM_TAKE_FOCUS (xd));
  1056.     if (n_protocols > 0)
  1057.       XSetWMProtocols
  1058.     ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&protocols[0]), n_protocols);
  1059.   }
  1060. }
  1061.  
  1062. /* The use of `XD_CACHED_EVENT' prevents an event from being lost due
  1063.    to garbage collection.  First `XD_CACHED_EVENT' is set to hold the
  1064.    current event, then the allocations are performed.  If one of them
  1065.    fails, the primitive will exit, and when it reenters it will notice
  1066.    the cached event and use it.  It is important that this be the only
  1067.    entry that reads events -- or else that all other event readers
  1068.    cooperate with this strategy.  */
  1069.  
  1070. static SCHEME_OBJECT
  1071. DEFUN (xd_process_events, (xd, non_block_p, use_select_p),
  1072.        struct xdisplay * xd AND
  1073.        int non_block_p AND
  1074.        int use_select_p)
  1075. {
  1076.   Display * display = (XD_DISPLAY (xd));
  1077.   unsigned int events_queued;
  1078.   if (!UX_have_select_p)
  1079.     use_select_p = 0;
  1080.   if (XD_CACHED_EVENT_P (xd))
  1081.     {
  1082.       events_queued = (XEventsQueued (display, QueuedAlready));
  1083.       goto restart;
  1084.     }
  1085.   events_queued =
  1086.     (use_select_p ? (XEventsQueued (display, QueuedAlready))
  1087.      : non_block_p ? (XEventsQueued (display, QueuedAfterReading))
  1088.      : 0);
  1089.   while (1)
  1090.     {
  1091.       XEvent event;
  1092.       if (events_queued > 0)
  1093.     events_queued -= 1;
  1094.       else if (use_select_p)
  1095.     switch (UX_select_input ((ConnectionNumber (display)),
  1096.                  (!non_block_p)))
  1097.       {
  1098.       case select_input_none:
  1099.         return (SHARP_F);
  1100.       case select_input_other:
  1101.         return (LONG_TO_FIXNUM (-2));
  1102.       case select_input_process_status:
  1103.         return (LONG_TO_FIXNUM (-3));
  1104.       case select_input_interrupt:
  1105.         return (LONG_TO_FIXNUM (-4));
  1106.       case select_input_argument:
  1107.         events_queued = (XEventsQueued (display, QueuedAfterReading));
  1108.         continue;
  1109.       }
  1110.       else if (non_block_p)
  1111.     return (SHARP_F);
  1112.       XNextEvent (display, (&event));
  1113.       if ((event . type) == KeymapNotify)
  1114.     continue;
  1115.       {
  1116.     struct xwindow * xw = (x_window_to_xw (event . xany . window));
  1117.     if (xw == 0)
  1118.       continue;
  1119.     xw_process_event (xw, (&event));
  1120.       }
  1121.       (XD_CACHED_EVENT (xd)) = event;
  1122.       (XD_CACHED_EVENT_P (xd)) = 1;
  1123.     restart:
  1124.       {
  1125.     SCHEME_OBJECT result = (x_event_to_object (&event));
  1126.     (XD_CACHED_EVENT_P (xd)) = 0;
  1127.     if (result != SHARP_F)
  1128.       return (result);
  1129.       }
  1130.     }
  1131. }
  1132.  
  1133. /* Open/Close Primitives */
  1134.  
  1135. static void
  1136. DEFUN_VOID (initialize_once)
  1137. {
  1138.   allocation_table_initialize (&x_display_table);
  1139.   allocation_table_initialize (&x_window_table);
  1140.   allocation_table_initialize (&x_image_table);
  1141.   XSetErrorHandler (x_error_handler);
  1142.   XSetIOErrorHandler (x_io_error_handler);
  1143.   add_reload_cleanup (x_close_all_displays);
  1144.   initialization_done = 1;
  1145. }
  1146.  
  1147. DEFINE_PRIMITIVE ("X-DEBUG", Prim_x_debug, 1, 1, 0)
  1148. {
  1149.   PRIMITIVE_HEADER (1);
  1150.   x_debug = (BOOLEAN_ARG (1));
  1151.   PRIMITIVE_RETURN (UNSPECIFIC);
  1152. }
  1153.  
  1154. DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0)
  1155. {
  1156.   PRIMITIVE_HEADER (1);
  1157.   INITIALIZE_ONCE ();
  1158.   {
  1159.     struct xdisplay * xd = (x_malloc (sizeof (struct xdisplay)));
  1160.     (XD_DISPLAY (xd)) =
  1161.       (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? 0 : (STRING_ARG (1))));
  1162.     if ((XD_DISPLAY (xd)) == 0)
  1163.       {
  1164.     free (xd);
  1165.     PRIMITIVE_RETURN (SHARP_F);
  1166.       }
  1167.     (XD_ALLOCATION_INDEX (xd)) =
  1168.       (allocate_table_index ((&x_display_table), xd));
  1169.     (XD_WM_PROTOCOLS (xd)) =
  1170.       (XInternAtom ((XD_DISPLAY (xd)), "WM_PROTOCOLS", False));
  1171.     (XD_WM_DELETE_WINDOW (xd)) =
  1172.       (XInternAtom ((XD_DISPLAY (xd)), "WM_DELETE_WINDOW", False));
  1173.     (XD_WM_TAKE_FOCUS (xd)) =
  1174.       (XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False));
  1175.     (XD_CACHED_EVENT_P (xd)) = 0;
  1176.     PRIMITIVE_RETURN (XD_TO_OBJECT (xd));
  1177.   }
  1178. }
  1179.  
  1180. DEFINE_PRIMITIVE ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0)
  1181. {
  1182.   PRIMITIVE_HEADER (1);
  1183.   x_close_display (x_display_arg (1));
  1184.   PRIMITIVE_RETURN (UNSPECIFIC);
  1185. }
  1186.  
  1187. DEFINE_PRIMITIVE ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0)
  1188. {
  1189.   PRIMITIVE_HEADER (0);
  1190.   INITIALIZE_ONCE ();
  1191.   x_close_all_displays ();
  1192.   PRIMITIVE_RETURN (UNSPECIFIC);
  1193. }
  1194.  
  1195. DEFINE_PRIMITIVE ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0)
  1196. {
  1197.   PRIMITIVE_HEADER (1);
  1198.   {
  1199.     struct xwindow * xw = (x_window_arg (1));
  1200.     Display * display = (XW_DISPLAY (xw));
  1201.     x_close_window (xw);
  1202.     XFlush (display);
  1203.   }
  1204.   PRIMITIVE_RETURN (UNSPECIFIC);
  1205. }
  1206.  
  1207. /* Event Processing Primitives */
  1208.  
  1209. DEFINE_PRIMITIVE ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, 2, 0)
  1210. {
  1211.   PRIMITIVE_HEADER (2);
  1212.   {
  1213.     struct xdisplay * xd = (x_display_arg (1));
  1214.     SCHEME_OBJECT how = (ARG_REF (2));
  1215.     if (how == SHARP_F)
  1216.       PRIMITIVE_RETURN (xd_process_events (xd, 0, 1));
  1217.     else if (how == (LONG_TO_UNSIGNED_FIXNUM (0)))
  1218.       PRIMITIVE_RETURN (xd_process_events (xd, 1, 1));
  1219.     else if (how == (LONG_TO_UNSIGNED_FIXNUM (1)))
  1220.       PRIMITIVE_RETURN (xd_process_events (xd, 0, 0));
  1221.     else
  1222.       PRIMITIVE_RETURN (xd_process_events (xd, 1, 0));
  1223.   }
  1224. }
  1225.  
  1226. DEFINE_PRIMITIVE ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0)
  1227. {
  1228.   PRIMITIVE_HEADER (1);
  1229.   PRIMITIVE_RETURN (long_to_integer (XW_EVENT_MASK (x_window_arg (1))));
  1230. }
  1231.  
  1232. DEFINE_PRIMITIVE ("X-WINDOW-SET-EVENT-MASK", Prim_x_window_set_event_mask, 2, 2, 0)
  1233. {
  1234.   PRIMITIVE_HEADER (2);
  1235.   {
  1236.     struct xwindow * xw = (x_window_arg (1));
  1237.     (XW_EVENT_MASK (xw)) = (EVENT_MASK_ARG (2));
  1238.     update_input_mask (xw);
  1239.   }
  1240.   PRIMITIVE_RETURN (UNSPECIFIC);
  1241. }
  1242.  
  1243. DEFINE_PRIMITIVE ("X-WINDOW-OR-EVENT-MASK", Prim_x_window_or_event_mask, 2, 2, 0)
  1244. {
  1245.   PRIMITIVE_HEADER (2);
  1246.   {
  1247.     struct xwindow * xw = (x_window_arg (1));
  1248.     (XW_EVENT_MASK (xw)) |= (EVENT_MASK_ARG (2));
  1249.     update_input_mask (xw);
  1250.   }
  1251.   PRIMITIVE_RETURN (UNSPECIFIC);
  1252. }
  1253.  
  1254. DEFINE_PRIMITIVE ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, 2, 0)
  1255. {
  1256.   PRIMITIVE_HEADER (2);
  1257.   {
  1258.     struct xwindow * xw = (x_window_arg (1));
  1259.     (XW_EVENT_MASK (xw)) &=~ (EVENT_MASK_ARG (2));
  1260.     update_input_mask (xw);
  1261.   }
  1262.   PRIMITIVE_RETURN (UNSPECIFIC);
  1263. }
  1264.  
  1265. /* Miscellaneous Primitives */
  1266.  
  1267. DEFINE_PRIMITIVE ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0)
  1268. {
  1269.   PRIMITIVE_HEADER (1);
  1270.   PRIMITIVE_RETURN (XD_TO_OBJECT (XW_XD (x_window_arg (1))));
  1271. }
  1272.  
  1273. DEFINE_PRIMITIVE ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0)
  1274. {
  1275.   PRIMITIVE_HEADER (1);
  1276.   PRIMITIVE_RETURN (long_to_integer (XW_X_SIZE (x_window_arg (1))));
  1277. }
  1278.  
  1279. DEFINE_PRIMITIVE ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0)
  1280. {
  1281.   PRIMITIVE_HEADER (1);
  1282.   PRIMITIVE_RETURN (long_to_integer (XW_Y_SIZE (x_window_arg (1))));
  1283. }
  1284.  
  1285. DEFINE_PRIMITIVE ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0)
  1286. {
  1287.   PRIMITIVE_HEADER (1);
  1288.   XBell ((XW_DISPLAY (x_window_arg (1))), 0); /* base value */
  1289.   PRIMITIVE_RETURN (UNSPECIFIC);
  1290. }
  1291.  
  1292. DEFINE_PRIMITIVE ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0)
  1293. {
  1294.   PRIMITIVE_HEADER (1);
  1295.   {
  1296.     struct xwindow * xw = (x_window_arg (1));
  1297.     XClearArea ((XW_DISPLAY (xw)),
  1298.         (XW_WINDOW (xw)),
  1299.         ((XW_CLIP_X (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))),
  1300.         ((XW_CLIP_Y (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))),
  1301.         (XW_CLIP_WIDTH (xw)),
  1302.         (XW_CLIP_HEIGHT (xw)),
  1303.         False);
  1304.   }
  1305.   PRIMITIVE_RETURN (UNSPECIFIC);
  1306. }
  1307.  
  1308. DEFINE_PRIMITIVE ("X-DISPLAY-FLUSH", Prim_x_display_flush, 1, 1, 0)
  1309. {
  1310.   PRIMITIVE_HEADER (1);
  1311.   XFlush (XD_DISPLAY (x_display_arg (1)));
  1312.   PRIMITIVE_RETURN (UNSPECIFIC);
  1313. }
  1314.  
  1315. DEFINE_PRIMITIVE ("X-DISPLAY-SYNC", Prim_x_display_sync, 2, 2, 0)
  1316. {
  1317.   PRIMITIVE_HEADER (2);
  1318.   XSync ((XD_DISPLAY (x_display_arg (1))), (BOOLEAN_ARG (2)));
  1319.   PRIMITIVE_RETURN (UNSPECIFIC);
  1320. }
  1321.  
  1322. DEFINE_PRIMITIVE ("X-DISPLAY-GET-DEFAULT", Prim_x_display_get_default, 3, 3, 0)
  1323. {
  1324.   PRIMITIVE_HEADER (3);
  1325.   {
  1326.     char * result =
  1327.       (XGetDefault
  1328.        ((XD_DISPLAY (x_display_arg (1))), (STRING_ARG (2)), (STRING_ARG (3))));
  1329.     PRIMITIVE_RETURN
  1330.       ((result == 0) ? SHARP_F
  1331.        : (char_pointer_to_string ((unsigned char *) result)));
  1332.   }
  1333. }
  1334.  
  1335. DEFINE_PRIMITIVE ("X-WINDOW-COORDS-ROOT->LOCAL", Prim_x_window_coords_root2local, 3, 3, 0)
  1336. {
  1337.   PRIMITIVE_HEADER (3);
  1338.   {
  1339.     SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
  1340.     struct xwindow * xw = (x_window_arg (1));
  1341.     Display * display = (XW_DISPLAY (xw));
  1342.     int rx = (arg_integer (2));
  1343.     int ry = (arg_integer (3));
  1344.     int wx;
  1345.     int wy;
  1346.     Window child;
  1347.     if (! (XTranslateCoordinates
  1348.        (display,
  1349.         (RootWindow (display, (DefaultScreen (display)))),
  1350.         (XW_WINDOW (xw)),
  1351.         rx, ry, (&wx), (&wy), (&child))))
  1352.       error_bad_range_arg (1);
  1353.     SET_PAIR_CAR (result, (long_to_integer (wx)));
  1354.     SET_PAIR_CDR (result, (long_to_integer (wy)));
  1355.     PRIMITIVE_RETURN (result);
  1356.   }
  1357. }
  1358.  
  1359. DEFINE_PRIMITIVE ("X-WINDOW-COORDS-LOCAL->ROOT", Prim_x_window_coords_local2root, 3, 3, 0)
  1360. {
  1361.   PRIMITIVE_HEADER (3);
  1362.   {
  1363.     SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
  1364.     struct xwindow * xw = (x_window_arg (1));
  1365.     Display * display = (XW_DISPLAY (xw));
  1366.     int wx = (arg_integer (2));
  1367.     int wy = (arg_integer (3));
  1368.     int rx;
  1369.     int ry;
  1370.     Window child;
  1371.     if (! (XTranslateCoordinates
  1372.        (display,
  1373.         (XW_WINDOW (xw)),
  1374.         (RootWindow (display, (DefaultScreen (display)))),
  1375.         wx, wy, (&rx), (&ry), (&child))))
  1376.       error_bad_range_arg (1);
  1377.     SET_PAIR_CAR (result, (long_to_integer (rx)));
  1378.     SET_PAIR_CDR (result, (long_to_integer (ry)));
  1379.     PRIMITIVE_RETURN (result);
  1380.   }
  1381. }
  1382.  
  1383. DEFINE_PRIMITIVE ("X-WINDOW-QUERY-POINTER", Prim_x_window_query_pointer, 1, 1, 0)
  1384. {
  1385.   PRIMITIVE_HEADER (1);
  1386.   {
  1387.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, 1));
  1388.     struct xwindow * xw = (x_window_arg (1));
  1389.     Window root;
  1390.     Window child;
  1391.     int root_x;
  1392.     int root_y;
  1393.     int win_x;
  1394.     int win_y;
  1395.     unsigned int keys_buttons;
  1396.     if (! (XQueryPointer
  1397.        ((XW_DISPLAY (xw)),
  1398.         (XW_WINDOW (xw)),
  1399.         (&root), (&child),
  1400.         (&root_x), (&root_y),
  1401.         (&win_x), (&win_y),
  1402.         (&keys_buttons))))
  1403.       PRIMITIVE_RETURN (SHARP_F);
  1404.     VECTOR_SET (result, 0, (long_to_integer (root_x)));
  1405.     VECTOR_SET (result, 1, (long_to_integer (root_y)));
  1406.     VECTOR_SET (result, 2, (long_to_integer (win_x)));
  1407.     VECTOR_SET (result, 3, (long_to_integer (win_y)));
  1408.     VECTOR_SET (result, 4, (convert_bucky_bits (keys_buttons, 1)));
  1409.     PRIMITIVE_RETURN (result);
  1410.   }
  1411. }
  1412.  
  1413. /* Appearance Control Primitives */
  1414.  
  1415. DEFINE_PRIMITIVE ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0)
  1416. {
  1417.   PRIMITIVE_HEADER (2);
  1418.   {
  1419.     struct xwindow * xw = (x_window_arg (1));
  1420.     Display * display = (XW_DISPLAY (xw));
  1421.     unsigned long foreground_pixel = (arg_color (2, display));
  1422.     (XW_FOREGROUND_PIXEL (xw)) = foreground_pixel;
  1423.     XSetForeground (display, (XW_NORMAL_GC (xw)), foreground_pixel);
  1424.     XSetBackground (display, (XW_REVERSE_GC (xw)), foreground_pixel);
  1425.   }
  1426.   PRIMITIVE_RETURN (UNSPECIFIC);
  1427. }
  1428.  
  1429. DEFINE_PRIMITIVE ("X-WINDOW-SET-BACKGROUND-COLOR", Prim_x_window_set_background_color, 2, 2, 0)
  1430. {
  1431.   PRIMITIVE_HEADER (2);
  1432.   {
  1433.     struct xwindow * xw = (x_window_arg (1));
  1434.     Display * display = (XW_DISPLAY (xw));
  1435.     unsigned long background_pixel = (arg_color (2, display));
  1436.     (XW_BACKGROUND_PIXEL (xw)) = background_pixel;
  1437.     XSetWindowBackground (display, (XW_WINDOW (xw)), background_pixel);
  1438.     XSetBackground (display, (XW_NORMAL_GC (xw)), background_pixel);
  1439.     XSetForeground (display, (XW_REVERSE_GC (xw)), background_pixel);
  1440.     XSetForeground (display, (XW_CURSOR_GC (xw)), background_pixel);
  1441.     x_set_mouse_colors
  1442.       (display,
  1443.        (XW_MOUSE_CURSOR (xw)),
  1444.        (XW_MOUSE_PIXEL (xw)),
  1445.        background_pixel);
  1446.   }
  1447.   PRIMITIVE_RETURN (UNSPECIFIC);
  1448. }
  1449.  
  1450. DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-COLOR", Prim_x_window_set_border_color, 2, 2, 0)
  1451. {
  1452.   PRIMITIVE_HEADER (2);
  1453.   {
  1454.     struct xwindow * xw = (x_window_arg (1));
  1455.     Display * display = (XW_DISPLAY (xw));
  1456.     unsigned long border_pixel = (arg_color (2, display));
  1457.     (XW_BORDER_PIXEL (xw)) = border_pixel;
  1458.     XSetWindowBorder (display, (XW_WINDOW (xw)), border_pixel);
  1459.   }
  1460.   PRIMITIVE_RETURN (UNSPECIFIC);
  1461. }
  1462.  
  1463. DEFINE_PRIMITIVE ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0)
  1464. {
  1465.   PRIMITIVE_HEADER (2);
  1466.   {
  1467.     struct xwindow * xw = (x_window_arg (1));
  1468.     Display * display = (XW_DISPLAY (xw));
  1469.     unsigned long cursor_pixel = (arg_color (2, display));
  1470.     (XW_CURSOR_PIXEL (xw)) = cursor_pixel;
  1471.     XSetBackground (display, (XW_CURSOR_GC (xw)), cursor_pixel);
  1472.   }
  1473.   PRIMITIVE_RETURN (UNSPECIFIC);
  1474. }
  1475.  
  1476. DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-COLOR", Prim_x_window_set_mouse_color, 2, 2, 0)
  1477. {
  1478.   PRIMITIVE_HEADER (2);
  1479.   {
  1480.     struct xwindow * xw = (x_window_arg (1));
  1481.     Display * display = (XW_DISPLAY (xw));
  1482.     unsigned long mouse_pixel = (arg_color (2, display));
  1483.     (XW_MOUSE_PIXEL (xw)) = mouse_pixel;
  1484.     x_set_mouse_colors
  1485.       (display,
  1486.        (XW_MOUSE_CURSOR (xw)),
  1487.        mouse_pixel,
  1488.        (XW_BACKGROUND_PIXEL (xw)));
  1489.   }
  1490.   PRIMITIVE_RETURN (UNSPECIFIC);
  1491. }
  1492.  
  1493. DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-SHAPE", Prim_x_window_set_mouse_shape, 2, 2, 0)
  1494. {
  1495.   PRIMITIVE_HEADER (2);
  1496.   {
  1497.     struct xwindow * xw = (x_window_arg (1));
  1498.     Display * display = (XW_DISPLAY (xw));
  1499.     Window window = (XW_WINDOW (xw));
  1500.     {
  1501.       Cursor old_cursor = (XW_MOUSE_CURSOR (xw));
  1502.       Cursor mouse_cursor =
  1503.     (XCreateFontCursor
  1504.      (display, (2 * (arg_index_integer (2, (XC_num_glyphs / 2))))));
  1505.       x_set_mouse_colors
  1506.     (display,
  1507.      mouse_cursor,
  1508.      (XW_MOUSE_PIXEL (xw)),
  1509.      (XW_BACKGROUND_PIXEL (xw)));
  1510.       (XW_MOUSE_CURSOR (xw)) = mouse_cursor;
  1511.       XDefineCursor (display, window, mouse_cursor);
  1512.       XFreeCursor (display, old_cursor);
  1513.     }
  1514.   }
  1515.   PRIMITIVE_RETURN (UNSPECIFIC);
  1516. }
  1517.  
  1518. DEFINE_PRIMITIVE ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0)
  1519. {
  1520.   PRIMITIVE_HEADER (2);
  1521.   {
  1522.     struct xwindow * xw = (x_window_arg (1));
  1523.     Display * display = (XW_DISPLAY (xw));
  1524.     XFontStruct * font = (XLoadQueryFont (display, (STRING_ARG (2))));
  1525.     if (font == 0)
  1526.       PRIMITIVE_RETURN (SHARP_F);
  1527.     XFreeFont (display, (XW_FONT (xw)));
  1528.     (XW_FONT (xw)) = font;
  1529.     {
  1530.       Font fid = (font -> fid);
  1531.       XSetFont (display, (XW_NORMAL_GC (xw)), fid);
  1532.       XSetFont (display, (XW_REVERSE_GC (xw)), fid);
  1533.       XSetFont (display, (XW_CURSOR_GC (xw)), fid);
  1534.     }
  1535.     if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
  1536.       (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
  1537.   }
  1538.   PRIMITIVE_RETURN (SHARP_T);
  1539. }
  1540.  
  1541. DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0)
  1542. {
  1543.   PRIMITIVE_HEADER (2);
  1544.   {
  1545.     struct xwindow * xw = (x_window_arg (1));
  1546.     Display * display = (XW_DISPLAY (xw));
  1547.     unsigned int border_width = (arg_nonnegative_integer (2));
  1548.     (XW_BORDER_WIDTH (xw)) = border_width;
  1549.     XSetWindowBorderWidth (display, (XW_WINDOW (xw)), border_width);
  1550.   }
  1551.   PRIMITIVE_RETURN (UNSPECIFIC);
  1552. }
  1553.  
  1554. DEFINE_PRIMITIVE ("X-WINDOW-SET-INTERNAL-BORDER-WIDTH", Prim_x_window_set_internal_border_width, 2, 2, 0)
  1555. {
  1556.   PRIMITIVE_HEADER (2);
  1557.   {
  1558.     struct xwindow * xw = (x_window_arg (1));
  1559.     unsigned int internal_border_width = (arg_nonnegative_integer (2));
  1560.     (XW_INTERNAL_BORDER_WIDTH (xw)) = internal_border_width;
  1561.     if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
  1562.       (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
  1563.     XResizeWindow
  1564.       ((XW_DISPLAY (xw)),
  1565.        (XW_WINDOW (xw)),
  1566.        ((XW_X_SIZE (xw)) + (2 * internal_border_width)),
  1567.        ((XW_Y_SIZE (xw)) + (2 * internal_border_width)));
  1568.   }
  1569.   PRIMITIVE_RETURN (UNSPECIFIC);
  1570. }
  1571.  
  1572. /* WM Communication Primitives */
  1573.  
  1574. DEFINE_PRIMITIVE ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2,
  1575.   "Set the name of WINDOW to STRING.")
  1576. {
  1577.   PRIMITIVE_HEADER (2);
  1578.   xw_set_wm_name ((x_window_arg (1)), (STRING_ARG (2)));
  1579.   PRIMITIVE_RETURN (UNSPECIFIC);
  1580. }
  1581.  
  1582. DEFINE_PRIMITIVE ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2,
  1583.   "Set the icon name of WINDOW to STRING.")
  1584. {
  1585.   PRIMITIVE_HEADER (2);
  1586.   xw_set_wm_icon_name ((x_window_arg (1)), (STRING_ARG (2)));
  1587.   PRIMITIVE_RETURN (UNSPECIFIC);
  1588. }
  1589.  
  1590. DEFINE_PRIMITIVE ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3,
  1591.   "Set the class hint of WINDOW to RESOURCE_NAME and RESOURCE_CLASS.")
  1592. {
  1593.   PRIMITIVE_HEADER (3);
  1594.   xw_set_class_hint ((x_window_arg (1)), (STRING_ARG (2)), (STRING_ARG (3)));
  1595.   PRIMITIVE_RETURN (UNSPECIFIC);
  1596. }
  1597.  
  1598. DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2,
  1599.   "Set the input hint of WINDOW to INPUT.")
  1600. {
  1601.   PRIMITIVE_HEADER (2);
  1602.   xw_set_wm_input_hint ((x_window_arg (1)), (BOOLEAN_ARG (2)));
  1603.   PRIMITIVE_RETURN (UNSPECIFIC);
  1604. }
  1605.  
  1606. DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0)
  1607. {
  1608.   PRIMITIVE_HEADER (2);
  1609.   {
  1610.     struct xwindow * xw = (x_window_arg (1));
  1611.     XSetInputFocus
  1612.       ((XW_DISPLAY (xw)),
  1613.        (XW_WINDOW (xw)),
  1614.        RevertToParent,
  1615.        ((Time) (arg_integer (2))));
  1616.   }
  1617.   PRIMITIVE_RETURN (UNSPECIFIC);
  1618. }
  1619.  
  1620. DEFINE_PRIMITIVE ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2,
  1621.   "Set the transient-for hint of WINDOW to PRIMARY-WINDOW.")
  1622. {
  1623.   PRIMITIVE_HEADER (2);
  1624.   {
  1625.     struct xwindow * xw = (x_window_arg (1));
  1626.     struct xwindow * transient_for = (x_window_arg (2));
  1627.     if ((xw == transient_for) || ((XW_XD (xw)) != (XW_XD (transient_for))))
  1628.       error_bad_range_arg (2);
  1629.     XSetTransientForHint
  1630.       ((XW_DISPLAY (xw)),
  1631.        (XW_WINDOW (xw)),
  1632.        (XW_WINDOW (transient_for)));
  1633.   }
  1634.   PRIMITIVE_RETURN (UNSPECIFIC);
  1635. }
  1636.  
  1637. /* WM Control Primitives */
  1638.  
  1639. DEFINE_PRIMITIVE ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0)
  1640. {
  1641.   PRIMITIVE_HEADER (1);
  1642.   {
  1643.     struct xwindow * xw = (x_window_arg (1));
  1644.     XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  1645.   }
  1646.   PRIMITIVE_RETURN (UNSPECIFIC);
  1647. }
  1648.  
  1649. DEFINE_PRIMITIVE ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0)
  1650. {
  1651.   PRIMITIVE_HEADER (1);
  1652.   {
  1653.     struct xwindow * xw = (x_window_arg (1));
  1654.     Display * display = (XW_DISPLAY (xw));
  1655.     XIconifyWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display)));
  1656.   }
  1657.   PRIMITIVE_RETURN (UNSPECIFIC);
  1658. }
  1659.  
  1660. DEFINE_PRIMITIVE ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0)
  1661. {
  1662.   PRIMITIVE_HEADER (1);
  1663.   {
  1664.     struct xwindow * xw = (x_window_arg (1));
  1665.     Display * display = (XW_DISPLAY (xw));
  1666.     XWithdrawWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display)));
  1667.   }
  1668.   PRIMITIVE_RETURN (UNSPECIFIC);
  1669. }
  1670.  
  1671. /* The following shouldn't be used on top-level windows.  Instead use
  1672.    ICONIFY or WITHDRAW.  */
  1673. DEFINE_PRIMITIVE ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0)
  1674. {
  1675.   PRIMITIVE_HEADER (1);
  1676.   {
  1677.     struct xwindow * xw = (x_window_arg (1));
  1678.     XUnmapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  1679.   }
  1680.   PRIMITIVE_RETURN (UNSPECIFIC);
  1681. }
  1682.  
  1683. DEFINE_PRIMITIVE ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0)
  1684. {
  1685.   PRIMITIVE_HEADER (3);
  1686.   {
  1687.     struct xwindow * xw = (x_window_arg (1));
  1688.     unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
  1689.     XResizeWindow
  1690.       ((XW_DISPLAY (xw)),
  1691.        (XW_WINDOW (xw)),
  1692.        ((arg_nonnegative_integer (2)) + extra),
  1693.        ((arg_nonnegative_integer (3)) + extra));
  1694.   }
  1695.   PRIMITIVE_RETURN (UNSPECIFIC);
  1696. }
  1697.  
  1698. DEFINE_PRIMITIVE ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0)
  1699. {
  1700.   /* Considerable hair to detect whether the window has been
  1701.      reparented by the window manager, and to translate the
  1702.      position to the parent's coordinates if so.  */
  1703.   PRIMITIVE_HEADER (3);
  1704.   {
  1705.     struct xwindow * xw = (x_window_arg (1));
  1706.     int x = (arg_integer (2));
  1707.     int y = (arg_integer (3));
  1708.     Display * display = (XW_DISPLAY (xw));
  1709.     Window me = (XW_WINDOW (xw));
  1710.     Window root;
  1711.     Window parent;
  1712.     Window * children;
  1713.     unsigned int n_children;
  1714.     if (! (XQueryTree (display, me,
  1715.                (&root), (&parent), (&children), (&n_children))))
  1716.       error_external_return ();
  1717.     XFree ((caddr_t) children);
  1718.     if (parent != root)
  1719.       {
  1720.     int px;
  1721.     int py;
  1722.     Window child;
  1723.     Window ancestor;
  1724.  
  1725.     while (1)
  1726.       {
  1727.         if (! (XQueryTree (display, parent,
  1728.                    (&root), (&ancestor),
  1729.                    (&children), (&n_children))))
  1730.           error_external_return ();
  1731.         XFree ((caddr_t) children);
  1732.         if (ancestor == root)
  1733.           break;
  1734.         parent = ancestor;
  1735.       }
  1736.     if (! (XTranslateCoordinates
  1737.            (display, me, parent, x, y, (&px), (&py), (&child))))
  1738.       error_bad_range_arg (1);
  1739.     x = px;
  1740.     y = py;
  1741.       }
  1742.     XMoveWindow (display, me, x, y);
  1743.   }
  1744.   PRIMITIVE_RETURN (UNSPECIFIC);
  1745. }
  1746.  
  1747. DEFINE_PRIMITIVE ("X-WINDOW-RAISE", Prim_x_window_raise, 1, 1, 0)
  1748. {
  1749.   PRIMITIVE_HEADER (1);
  1750.   {
  1751.     struct xwindow * xw = (x_window_arg (1));
  1752.     XRaiseWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  1753.   }
  1754.   PRIMITIVE_RETURN (UNSPECIFIC);
  1755. }
  1756.  
  1757. DEFINE_PRIMITIVE ("X-WINDOW-LOWER", Prim_x_window_lower, 1, 1, 0)
  1758. {
  1759.   PRIMITIVE_HEADER (1);
  1760.   {
  1761.     struct xwindow * xw = (x_window_arg (1));
  1762.     XLowerWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  1763.   }
  1764.   PRIMITIVE_RETURN (UNSPECIFIC);
  1765. }
  1766.  
  1767. /* Font Structure Primitive */
  1768.  
  1769. static SCHEME_OBJECT
  1770. DEFUN (convert_char_struct, (char_struct), XCharStruct * char_struct)
  1771. {
  1772.   if (((char_struct -> lbearing) == 0)
  1773.       && ((char_struct -> rbearing) == 0)
  1774.       && ((char_struct -> width) == 0)
  1775.       && ((char_struct -> ascent) == 0)
  1776.       && ((char_struct -> descent) == 0))
  1777.     return (SHARP_F);
  1778.   {
  1779.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, true));
  1780.     VECTOR_SET (result, 0, (long_to_integer (char_struct -> lbearing)));
  1781.     VECTOR_SET (result, 1, (long_to_integer (char_struct -> rbearing)));
  1782.     VECTOR_SET (result, 2, (long_to_integer (char_struct -> width)));
  1783.     VECTOR_SET (result, 3, (long_to_integer (char_struct -> ascent)));
  1784.     VECTOR_SET (result, 4, (long_to_integer (char_struct -> descent)));
  1785.     return (result);
  1786.   }
  1787. }
  1788.  
  1789. DEFINE_PRIMITIVE ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2, 0)
  1790. {
  1791.   PRIMITIVE_HEADER (2);
  1792.   {
  1793.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 10, true));
  1794.     SCHEME_OBJECT font_name = (ARG_REF (2));
  1795.     Display * display = (XD_DISPLAY (x_display_arg (1)));
  1796.     XFontStruct * font =
  1797.       (XLoadQueryFont (display, ((char *) (STRING_LOC (font_name, 0)))));
  1798.     if (font == 0)
  1799.       PRIMITIVE_RETURN (SHARP_F);
  1800.     /* Handle only 8-bit fonts because of laziness. */
  1801.     if (((font -> min_byte1) != 0) || ((font -> max_byte1) != 0))
  1802.       {
  1803.     XFreeFont (display, font);
  1804.     PRIMITIVE_RETURN (SHARP_F);
  1805.       }
  1806.     if ((font -> per_char) == NULL)
  1807.       VECTOR_SET (result, 6, SHARP_F);
  1808.     else
  1809.       {
  1810.     unsigned int start_index = (font -> min_char_or_byte2);
  1811.     unsigned int length = ((font -> max_char_or_byte2) - start_index + 1);
  1812.     SCHEME_OBJECT character_vector =
  1813.       (allocate_marked_vector (TC_VECTOR, length, true));
  1814.     unsigned int index;
  1815.     for (index = 0; (index < length); index += 1)
  1816.       VECTOR_SET (character_vector,
  1817.               index,
  1818.               (convert_char_struct ((font -> per_char) + index)));
  1819.     VECTOR_SET (result, 6, (long_to_integer (start_index)));
  1820.     VECTOR_SET (result, 7, character_vector);
  1821.       }
  1822.     VECTOR_SET (result, 0, font_name);
  1823.     VECTOR_SET (result, 1, (long_to_integer (font -> direction)));
  1824.     VECTOR_SET (result, 2,
  1825.         (BOOLEAN_TO_OBJECT ((font -> all_chars_exist) == True)));
  1826.     VECTOR_SET (result, 3, (long_to_integer (font -> default_char)));
  1827.     VECTOR_SET (result, 4, convert_char_struct (& (font -> min_bounds)));
  1828.     VECTOR_SET (result, 5, convert_char_struct (& (font -> max_bounds)));
  1829.     VECTOR_SET (result, 8, (long_to_integer (font -> ascent)));
  1830.     VECTOR_SET (result, 9, (long_to_integer (font -> descent)));
  1831.     XFreeFont (display, font);
  1832.     PRIMITIVE_RETURN (result);
  1833.   }
  1834. }
  1835.